home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / PAINT.PAK / BITMAPS.PAS next >
Pascal/Delphi Source File  |  1992-06-08  |  8KB  |  257 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows: Paint Demo         }
  4. {   Bitmaps unit                                 }
  5. {   Copyright (c) 1992 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit Bitmaps;
  10.  
  11. { This unit augments the HBitmap type by implementing load and store of the
  12.   bitmap to a file.
  13.  
  14.   Presently operates only on Windows format for bitmaps.
  15. }
  16. {$S-,R-}
  17.  
  18. interface
  19.  
  20. uses WinTypes, WinProcs;
  21.  
  22. { Read a bitmap from file (full pathname).
  23.   Returns 0 if error or HBitmap.
  24. }
  25. function LoadBitmapFile(FileName: PChar): HBitmap;
  26.  
  27. { Write a bitmap to file (full pathname).
  28.   Returns 0 if error else non-zero.
  29. }
  30. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  31.  
  32. implementation
  33.  
  34. procedure AHIncr; far; external 'KERNEL' index 114;
  35.  
  36. const
  37.   MaxIO = 65534;    { Max number bytes handled in single IO operation }
  38.   OneIO = 32768;  { Number bytes handled per huge IO operation }
  39.   BMType = $4D42;  { = 'BM' }
  40.  
  41. type
  42.   PtrRec = record
  43.     Lo, Hi: Word
  44.   end;
  45.   IOFunction = function(FP: integer; Buf: PChar; Size: Integer): Word;
  46.  
  47. { Perform IO operation in chunks to avoid memory segment crossings.
  48.   Returns 0 if error else non-zero.
  49. }
  50. function HugeIO(IOFunc: IOFunction; F: Integer; P: Pointer; Size: Longint)
  51.                : Word;
  52. var
  53.   L, N: Longint;                { L maintains total bytes }
  54. begin                { N maintains bytes for current pass }
  55.   HugeIO := 1;
  56.   L := 0;
  57.   while L < Size do
  58.   begin
  59.     N := Size - L;
  60.     if N > OneIO then N := OneIO;
  61.     if IOFunc(F,
  62.     { Compute the segment and offset reached.
  63.       The Hi word of P contains the initial segment.
  64.       Think of the following as performing arithmetic
  65.         modulo segment-size, since the size of a segment
  66.         fills one word:
  67.       The Hi word of L contains the number of segments crossed
  68.         (the size of one segment fills the Lo word, so Hi word
  69.         will roll over as segments are filled).
  70.         Multiply by Ofs(AHIncr) to obtain the number used to
  71.         indicate this number of segments.
  72.       The Lo word of L contains the number of bytes already
  73.         passed in the present segment.
  74.      }
  75.            Ptr(PtrRec(P).Hi + PtrRec(L).Hi * Ofs(AHIncr),
  76.                PtrRec(L).Lo),
  77.                Integer(N))     { Guaranteed to be in Integer range }
  78.        <> N then
  79.     begin
  80.       HugeIO := 0;
  81.       Exit; { abnormal termination }
  82.     end; 
  83.     Inc(L, N);
  84.   end;
  85. end;
  86.  
  87. function _LFileSize(F : integer) : longint;        
  88. {- an equivalent to TP's FileSize() function }     
  89. var                                                
  90.   CurPos : longint;                                
  91. begin                                               
  92.   CurPos := _llseek(F,0,1);                    
  93.   _LFileSize := _llseek(F,0,2);                
  94.   _llseek(F,CurPos,0);                         
  95. end;                                           
  96.  
  97. { Read a bitmap from file (full pathname).
  98.   Returns 0 if error or HBitmap.
  99. }
  100. function LoadBitmapFile(FileName: PChar): HBitmap;
  101. var
  102.   F: Integer;            { File Handle for Windows file functions }
  103.   H: THandle;            { Handle to memory for bitmap }
  104.   DC: HDC;            { Drawing context for application }
  105.   Size, N: Longint;        { Size of bitmap, Size of color spec }
  106.   P: PBitmapInfo;        { Windows bitmap format info header }
  107.   Header: TBitmapFileHeader;    { Bitmap file header }
  108.  
  109. begin
  110.   LoadBitmapFile := 0;
  111.   F := _LOpen(FileName, of_Read);
  112.   if F = -1 then Exit;
  113.  
  114.   { read in the Bitmap file header }
  115.   if (_LRead(F, @Header, SizeOf(Header)) <> SizeOf(Header)) or
  116.     (Header.bfType <> BMType) then
  117.   begin
  118.     _LClose(F);
  119.     Exit;
  120.   end;
  121.  
  122.   { read the rest of the file }
  123.   Size := _LFileSize(F) - SizeOf(TBitmapFileHeader);     
  124.   H := GlobalAlloc(gmem_Moveable, Size);    { Allocate the memory }
  125.   if H = 0 then
  126.   begin
  127.     _LClose(F);
  128.     Exit;
  129.   end;
  130.  
  131.   P := GlobalLock(H);                { Lock it down }
  132.  
  133.   if (HugeIO(_LRead, F, P, Size) <> 0) and
  134.     (P^.bmiHeader.biSize = SizeOf(TBitmapInfoHeader)) then
  135.   begin
  136.     { Compute the offset from the beginning of P^ }      
  137.     { where the actual image begins }                    
  138.     N := Header.bfOffBits - SizeOf(TBitmapFileHeader);
  139.  
  140.     { actually create the Bitmap }
  141.     DC := GetDC(0);
  142.     LoadBitmapFile := CreateDIBitmap(DC, P^.bmiHeader,
  143.       cbm_Init, Ptr(PtrRec(P).Hi,N),P^, dib_RGB_Colors); 
  144.  
  145.     { clean up }
  146.     ReleaseDC(0, DC);
  147.   end;
  148.  
  149.   GlobalUnlock(H);
  150.   GlobalFree(H);
  151.   _LClose(F);
  152. end;
  153.  
  154.  
  155. { Write a bitmap to file (full pathname).
  156.   Returns 0 if error else non-zero.
  157. }
  158. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  159.   var
  160.     BM:   TBitmap;        { Bitmap information }
  161.     BFH:  TBitmapFileHeader;    { Bitmap file information }
  162.     BIP:  PBitmapInfo;        { Part of bitmap file information }
  163.     DC:   HDC;            { Drawing context }
  164.  
  165.     HMem: THandle;        { Handle to memory for bitmap }
  166.     Buf:  Pointer;        { Memory for bitmap }
  167.  
  168.     ColorSize, DataSize: Longint; { Size needed to store Color/Data }
  169.     BitCount: Word;        { Number of bits per pixel }
  170.     FP: Integer;        { File }
  171.  
  172.   { Takes the size in bits and returns the (aligned) size in bytes.
  173.     Bitmap data format requires word alignment.
  174.   }
  175.   function bmAlignDouble(Size: Longint): Longint;
  176.   begin
  177.     bmAlignDouble := (Size + 31) div 32 * 4;
  178.   end;
  179.  
  180. begin
  181.    StoreBitmapFile := 0;
  182.    { Get the information about the Bitmap }
  183.    if GetObject(HBM, SizeOf(TBitmap), @BM) = 0 then Exit;
  184.  
  185.    BitCount := bm.bmPlanes * bm.bmBitsPixel;
  186.    if (BitCount <> 24) then
  187.      ColorSize := SizeOf(TRGBQuad) * (1 shl BitCount)
  188.    else
  189.      ColorSize := 0;
  190.    DataSize := bmAlignDouble(bm.bmWidth * BitCount) * bm.bmHeight;
  191.  
  192.    { Create the file }
  193.    FP := _lcreat(FileName, 0);
  194.    if FP = -1 then Exit;
  195.  
  196.    { Allocate memory for the bitmap info structure }
  197.    GetMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  198.    if BIP <> nil then
  199.    begin
  200.      { Fill in the Bitmap info header }
  201.      with BIP^.bmiHeader do
  202.      begin
  203.        biSize := SizeOf(TBitmapInfoHeader);
  204.        biWidth := bm.bmWidth;
  205.        biHeight := bm.bmHeight;
  206.        biPlanes := 1;
  207.        biBitCount := BitCount;
  208.        biCompression := 0;
  209.        biSizeImage := DataSize;
  210.        biXPelsPerMeter := 0;
  211.        biYPelsPerMeter := 0;
  212.        biClrUsed := 0;
  213.        biClrImportant := 0;
  214.      end;
  215.  
  216.      { Fill in the file header }
  217.      with BFH do
  218.      begin
  219.        bfOffBits := SizeOf(BFH) + SizeOf(TBitmapInfo) + ColorSize;
  220.        bfReserved1 := 0;
  221.        bfReserved2 := 0;
  222.        bfSize :=  bfOffBits + DataSize;
  223.        bfType := BMType;
  224.      end;
  225.  
  226.      { Create the memory Bitmap }
  227.      HMem := GlobalAlloc(gmem_Fixed, DataSize);
  228.      if HMem <> 0 then
  229.      begin
  230.        Buf := GlobalLock(HMem);
  231.  
  232.        { Get the bitmap bits in device independent format }
  233.        DC := GetDC(0);
  234.        if GetDIBits(DC, hbm, 0, DataSize, Buf, BIP^, dib_RGB_Colors) <> 0 then
  235.        begin
  236.          ReleaseDC(0, DC);
  237.          { Write to file }
  238.          _lwrite(FP, @BFH, SizeOf(BFH));
  239.          _lwrite(FP, PChar(BIP), SizeOf(TBitmapInfo) + ColorSize);
  240.          HugeIO(_lwrite, FP, Buf, DataSize);
  241.          StoreBitmapFile := 1;
  242.        end;
  243.  
  244.        { Clean up }
  245.        GlobalUnlock(HMem);
  246.        GlobalFree(HMem);
  247.      end;
  248.  
  249.      FreeMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  250.    end;
  251.  
  252.    _lclose(FP);
  253.  
  254. end;
  255.  
  256. end.
  257.